home *** CD-ROM | disk | FTP | other *** search
/ Aminet 1 (Walnut Creek) / Aminet - June 1993 [Walnut Creek].iso / usenet / sources / volume2 / aplictns / matlab / src.1 < prev    next >
Internet Message Format  |  1988-11-02  |  49KB
  1. Path: xanth!nic.MR.NET!hal!cwjcc!mailrus!ulowell!page
  2. From: page@swan.ulowell.edu (Bob Page)
  3. Newsgroups: comp.sources.amiga
  4. Subject: v02i041:  matlab - matrix laboratory, Part01/11
  5. Message-ID: <10016@swan.ulowell.edu>
  6. Date: 2 Nov 88 21:38:51 GMT
  7. Organization: University of Lowell, Computer Science Dept.
  8. Lines: 1251
  9. Approved: page@swan.ulowell.edu
  10.  
  11. Submitted-by: strovink%galaxy-43@afit-ab.arpa (Mark A. Strovink)
  12. Posting-number: Volume 2, Issue 41
  13. Archive-name: applications/matlab/src.1
  14.  
  15. MATLAB stands for MATrix LABoratory.  It is a FORTRAN package
  16. developed by Argonne National Laboratories for in-house use.  It
  17. provides comprehensive vector and tensor operations in a package which
  18. may be programmed, either through a macro language or through
  19. execution of script files.
  20.  
  21. Matlab is reentrant and recursive.  Functions supported include (but
  22. not by any means limited to) sin, cos, tan, arcfunctions, upper
  23. triangular, lower triangular, determinants, matrix multiplication,
  24. identity, hilbert matrices, eigenvalues and eigenvectors, matrix roots
  25. and products, inversion and so on and so forth.
  26.  
  27. The porter, Jim Locker, can be reached by phone at (513)-429-2771 from
  28. 8-5EST Mon-Fri.  Jim says he is willing to "amigatize" matlab if there
  29. is enough interest.  So if you want pulldown menus, snazzy graphics,
  30. better plotting, etc, write or call Jim.  For $5 he will send the
  31. complete package (all of this plus a manual).  His address is: 4443 N.
  32. Hyland Ave, Dayton OH  45424
  33.  
  34. Bob Walker, rbw%beta@lanl.gov, compiled the current matlab source with
  35. the Absoft fortran compiler v2.3.  The older compiler caused Matlab to
  36. crash whenever you tried to write to a write-protected disk.  There
  37. are no known bugs in the current version.
  38.  
  39. [to re-create the distribution, join src-1 through src-7 to produce
  40. matlab.for.  Then join help-1 and help-2 to produce help.lis.
  41. Finally, join doc-1 and doc-2 to produce matlab.doc.  Executable and
  42. SYM file will appear in comp.binaries.amiga.  Docs will only appear in
  43. the sources group, in parts 8-11 (they're too big to distribute
  44. twice).  ..Bob]
  45.  
  46. #    This is a shell archive.
  47. #    Remove everything above and including the cut line.
  48. #    Then run the rest of the file through sh.
  49. #----cut here-----cut here-----cut here-----cut here----#
  50. #!/bin/sh
  51. # shar:    Shell Archiver
  52. #    Run the following text with /bin/sh to create:
  53. #    src-1
  54. # This archive created: Wed Nov  2 16:20:05 1988
  55. cat << \SHAR_EOF > src-1
  56. C     PROGRAM MAIN FOR Amiga            
  57.       PROGRAM BIGMAT
  58.       CALL MATLAB(0)   
  59.       STOP             
  60.       END              
  61.               
  62.       SUBROUTINE CLAUSE                   
  63.       DOUBLE PRECISION STKR(5005),STKI(5005)                 
  64.       INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP        
  65.       INTEGER IDS(4,32),PSTK(32),RSTK(32),PSIZE,PT,PTZ       
  66.       INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE    
  67.       INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)            
  68.       COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP          
  69.       COMMON /RECU/ IDS,PSTK,RSTK,PSIZE,PT,PTZ               
  70.       COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE          
  71.       COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN  
  72.       INTEGER FOR(4),WHILE(4),IFF(4),ELSE(4),ENND(4),DO(4),THENN(4)             
  73.       INTEGER SEMI,EQUAL,EOL,BLANK,R      
  74.       INTEGER OP,COMMA,LESS,GREAT,NAME    
  75.       LOGICAL EQID     
  76.       DOUBLE PRECISION E1,E2              
  77.       DATA SEMI/39/,EQUAL/46/,EOL/99/,BLANK/36/              
  78.       DATA COMMA/48/,LESS/50/,GREAT/51/,NAME/1/              
  79.       DATA FOR/15,24,27,36/,WHILE/32,17,18,21/,IFF/18,15,36,36/                 
  80.       DATA ELSE/14,21,28,14/,ENND/14,23,13,36/               
  81.       DATA DO/13,24,36,36/,THENN/29,17,14,23/                
  82.       R = -FIN-10      
  83.       FIN = 0          
  84.       IF (DDT .EQ. 1) WRITE(WTE,100) PT,RSTK(PT),R           
  85.   100 FORMAT(1X,'CLAUSE',3I4)             
  86.       IF (R.LT.1 .OR. R.GT.6) GO TO 01    
  87.       GO TO (02,30,30,80,99,90),R         
  88.    01 R = RSTK(PT)     
  89.       GO TO (99,99,05,40,45,99,99,99,99,99,99,99,15,55,99,99,99),R              
  90. C                      
  91. C     FOR              
  92. C                      
  93.    02 CALL GETSYM      
  94.       IF (SYM .NE. NAME) CALL ERROR(34)   
  95.       IF (ERR .GT. 0) RETURN              
  96.       PT = PT+2        
  97.       CALL PUTID(IDS(1,PT),SYN)           
  98.       CALL GETSYM      
  99.       IF (SYM .NE. EQUAL) CALL ERROR(34)  
  100.       IF (ERR .GT. 0) RETURN              
  101.       CALL GETSYM      
  102.       RSTK(PT) = 3     
  103. C     *CALL* EXPR      
  104.       RETURN           
  105.    05 PSTK(PT-1) = 0   
  106.       PSTK(PT) = LPT(4) - 1               
  107.       IF (EQID(SYN,DO)) SYM = SEMI        
  108.       IF (SYM .EQ. COMMA) SYM = SEMI      
  109.       IF (SYM .NE. SEMI) CALL ERROR(34)   
  110.       IF (ERR .GT. 0) RETURN              
  111.    10 J = PSTK(PT-1)   
  112.       LPT(4) = PSTK(PT)                   
  113.       SYM = SEMI       
  114.       CHAR = BLANK     
  115.       J = J+1          
  116.       L = LSTK(TOP)    
  117.       M = MSTK(TOP)    
  118.       N = NSTK(TOP)    
  119.       LJ = L+(J-1)*M   
  120.       L2 = L + M*N     
  121.       IF (M .NE. -3) GO TO 12             
  122.       LJ = L+3         
  123.       L2 = LJ          
  124.       STKR(LJ) = STKR(L) + DFLOAT(J-1)*STKR(L+1)             
  125.       STKI(LJ) = 0.0   
  126.       IF (STKR(L+1).GT.0.0D0 .AND. STKR(LJ).GT.STKR(L+2)) GO TO 20              
  127.       IF (STKR(L+1).LT.0.0D0 .AND. STKR(LJ).LT.STKR(L+2)) GO TO 20              
  128.       M = 1            
  129.       N = J            
  130.    12 IF (J .GT. N) GO TO 20              
  131.       IF (TOP+1 .GE. BOT) CALL ERROR(18)  
  132.       IF (ERR .GT. 0) RETURN              
  133.       TOP = TOP+1      
  134.       LSTK(TOP) = L2   
  135.       MSTK(TOP) = M    
  136.       NSTK(TOP) = 1    
  137.       ERR = L2+M - LSTK(BOT)              
  138.       IF (ERR .GT. 0) CALL ERROR(17)      
  139.       IF (ERR .GT. 0) RETURN              
  140.       CALL WCOPY(M,STKR(LJ),STKI(LJ),1,STKR(L2),STKI(L2),1)  
  141.       RHS = 0          
  142.       CALL STACKP(IDS(1,PT))              
  143.       IF (ERR .GT. 0) RETURN              
  144.       PSTK(PT-1) = J   
  145.       PSTK(PT) = LPT(4)                   
  146.       RSTK(PT) = 13    
  147. C     *CALL* PARSE     
  148.       RETURN           
  149.    15 GO TO 10         
  150.    20 MSTK(TOP) = 0    
  151.       NSTK(TOP) = 0    
  152.       RHS = 0          
  153.       CALL STACKP(IDS(1,PT))              
  154.       IF (ERR .GT. 0) RETURN              
  155.       PT = PT-2        
  156.       GO TO 80         
  157. C                      
  158. C     WHILE OR IF      
  159. C                      
  160.    30 PT = PT+1        
  161.       CALL PUTID(IDS(1,PT),SYN)           
  162.       PSTK(PT) = LPT(4)-1                 
  163.    35 LPT(4) = PSTK(PT)                   
  164.       CHAR = BLANK     
  165.       CALL GETSYM      
  166.       RSTK(PT) = 4     
  167. C     *CALL* EXPR      
  168.       RETURN           
  169.    40 IF (SYM.NE.EQUAL .AND. SYM.NE.LESS .AND. SYM.NE.GREAT) 
  170.      $    CALL ERROR(35)                  
  171.       IF (ERR .GT. 0) RETURN              
  172.       OP = SYM         
  173.       CALL GETSYM      
  174.       IF (SYM.EQ.EQUAL .OR. SYM.EQ.GREAT) OP = OP + SYM      
  175.       IF (OP .GT. GREAT) CALL GETSYM      
  176.       PSTK(PT) = 256*PSTK(PT) + OP        
  177.       RSTK(PT) = 5     
  178. C     *CALL* EXPR      
  179.       RETURN           
  180.    45 OP = MOD(PSTK(PT),256)              
  181.       PSTK(PT) = PSTK(PT)/256             
  182.       L = LSTK(TOP-1)                     
  183.       E1 = STKR(L)     
  184.       L = LSTK(TOP)    
  185.       E2 = STKR(L)     
  186.       TOP = TOP - 2    
  187.       IF (EQID(SYN,DO) .OR. EQID(SYN,THENN)) SYM = SEMI      
  188.       IF (SYM .EQ. COMMA) SYM = SEMI      
  189.       IF (SYM .NE. SEMI) CALL ERROR(35)   
  190.       IF (ERR .GT. 0) RETURN              
  191.       IF (OP.EQ.EQUAL         .AND. E1.EQ.E2) GO TO 50       
  192.       IF (OP.EQ.LESS          .AND. E1.LT.E2) GO TO 50       
  193.       IF (OP.EQ.GREAT         .AND. E1.GT.E2) GO TO 50       
  194.       IF (OP.EQ.(LESS+EQUAL)  .AND. E1.LE.E2) GO TO 50       
  195.       IF (OP.EQ.(GREAT+EQUAL) .AND. E1.GE.E2) GO TO 50       
  196.       IF (OP.EQ.(LESS+GREAT)  .AND. E1.NE.E2) GO TO 50       
  197.       PT = PT-1        
  198.       GO TO 80         
  199.    50 RSTK(PT) = 14    
  200. C     *CALL* PARSE     
  201.       RETURN           
  202.    55 IF (EQID(IDS(1,PT),WHILE)) GO TO 35                    
  203.       PT = PT-1        
  204.       IF (EQID(SYN,ELSE)) GO TO 80        
  205.       RETURN           
  206. C                      
  207. C     SEARCH FOR MATCHING END OR ELSE     
  208.    80 KOUNT = 0        
  209.       CALL GETSYM      
  210.    82 IF (SYM .EQ. EOL) RETURN            
  211.       IF (SYM .NE. NAME) GO TO 83         
  212.       IF (EQID(SYN,ENND) .AND. KOUNT.EQ.0) RETURN            
  213.       IF (EQID(SYN,ELSE) .AND. KOUNT.EQ.0) RETURN            
  214.       IF (EQID(SYN,ENND) .OR. EQID(SYN,ELSE))                
  215.      $       KOUNT = KOUNT-1              
  216.       IF (EQID(SYN,FOR) .OR. EQID(SYN,WHILE)                 
  217.      $       .OR. EQID(SYN,IFF)) KOUNT = KOUNT+1             
  218.    83 CALL GETSYM      
  219.       GO TO 82         
  220. C                      
  221. C     EXIT FROM LOOP   
  222.    90 IF (DDT .EQ. 1) WRITE(WTE,190) (RSTK(I),I=1,PT)        
  223.   190 FORMAT(1X,'EXIT  ',10I4)            
  224.       IF (RSTK(PT) .EQ. 14) PT = PT-1     
  225.       IF (PT .LE. PTZ) RETURN             
  226.       IF (RSTK(PT) .EQ. 14) PT = PT-1     
  227.       IF (PT-1 .LE. PTZ) RETURN           
  228.       IF (RSTK(PT) .EQ. 13) TOP = TOP-1   
  229.       IF (RSTK(PT) .EQ. 13) PT = PT-2     
  230.       GO TO 80         
  231. C                      
  232.    99 CALL ERROR(22)   
  233.       IF (ERR .GT. 0) RETURN              
  234.       RETURN           
  235.       END
  236.               
  237.       SUBROUTINE COMAND(ID)               
  238.       INTEGER ID(4)    
  239.       DOUBLE PRECISION STKR(5005),STKI(5005)                 
  240.       INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP        
  241.       INTEGER ALFA(52),ALFB(52),ALFL,CASE                    
  242.       INTEGER IDS(4,32),PSTK(32),RSTK(32),PSIZE,PT,PTZ       
  243.       INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE           
  244.       INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)            
  245.       COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP          
  246.       COMMON /ALFS/ ALFA,ALFB,ALFL,CASE   
  247.       COMMON /RECU/ IDS,PSTK,RSTK,PSIZE,PT,PTZ               
  248.       COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE                  
  249.       COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN  
  250.       INTEGER CMD(4,17),CMDL,A,D,E,Z,LRECL,CH,BLANK,NAME,DOT,H(4)               
  251.       INTEGER SEMI,COMMA,EOL              
  252.       DOUBLE PRECISION URAND              
  253.       LOGICAL EQID     
  254.       DATA CMDL/17/,A/10/,D/13/,E/14/,Z/35/,EOL/99/,SEMI/39/,COMMA/48/          
  255.       DATA BLANK/36/,NAME/1/,DOT/47/      
  256. C                      
  257. C       CLEAR ELSE  END   EXIT            
  258. C       FOR   HELP  IF    LONG            
  259. C       RETUR SEMI     
  260. C       SHORT WHAT  WHILE                 
  261. C       WHO   WHY   LALA  FOO             
  262.       DATA CMD/        
  263.      $  12,21,14,10, 14,21,28,14, 14,23,13,36, 14,33,18,29,  
  264.      $  15,24,27,36, 17,14,21,25, 18,15,36,36, 21,24,23,16,  
  265.      $  27,14,29,30, 28,14,22,18,         
  266.      $  28,17,24,27, 32,17,10,29, 32,17,18,21,               
  267.      $  32,17,24,36, 32,17,34,36, 21,10,21,10, 15,30,12,20/  
  268. C                      
  269.       DATA LRECL/80/   
  270.   101 FORMAT(80A1)     
  271.   102 FORMAT(1X,80A1)                     
  272. C                      
  273.       IF (DDT .EQ. 1) WRITE(WTE,100)      
  274.   100 FORMAT(1X,'COMAND')                 
  275.       FUN = 0          
  276.       DO 10 K = 1, CMDL                   
  277.         IF (EQID(ID,CMD(1,K))) GO TO 20   
  278.    10 CONTINUE         
  279.       FIN = 0          
  280.       RETURN           
  281. C                      
  282.    20 IF (CHAR.EQ.COMMA .OR. CHAR.EQ.SEMI .OR. CHAR.EQ.EOL) GO TO 22            
  283.       IF (CHAR.LE.Z .OR. K.EQ.6) GO TO 22                    
  284.       CALL ERROR(16)   
  285.       RETURN           
  286. C                      
  287.    22 FIN = 1          
  288.       GO TO (25,36,38,40,30,80,34,52,44,55,50,65,32,60,70,46,48),K              
  289. C                      
  290. C     CLEAR            
  291.    25 IF (CHAR.GE.A .AND. CHAR.LE.Z) GO TO 26                
  292.       BOT = LSIZE-3    
  293.       GO TO 98         
  294.    26 CALL GETSYM      
  295.       TOP = TOP+1      
  296.       MSTK(TOP) = 0    
  297.       NSTK(TOP) = 0    
  298.       RHS = 0          
  299.       CALL STACKP(SYN)                    
  300.       IF (ERR .GT. 0) RETURN              
  301.       FIN = 1          
  302.       GO TO 98         
  303. C                      
  304. C     FOR, WHILE, IF, ELSE, END           
  305.    30 FIN = -11        
  306.       GO TO 99         
  307.    32 FIN = -12        
  308.       GO TO 99         
  309.    34 FIN = -13        
  310.       GO TO 99         
  311.    36 FIN = -14        
  312.       GO TO 99         
  313.    38 FIN = -15        
  314.       GO TO 99         
  315. C                      
  316. C     EXIT             
  317.    40 IF (PT .GT. PTZ) FIN = -16          
  318.       IF (PT .GT. PTZ) GO TO 98           
  319.       K = IDINT(STKR(VSIZE-2))            
  320.       WRITE(WTE,140) K                    
  321.       IF (WIO .NE. 0) WRITE(WIO,140) K    
  322.   140 FORMAT(/1X,'total flops ',I9//1X,'ADIOS'/)             
  323.       FUN = 99         
  324.       GO TO 98         
  325. C                      
  326. C     RETURN           
  327.    44 K = LPT(1) - 7   
  328.       IF (K .LE. 0) FUN = 99              
  329.       IF (K .LE. 0) GO TO 98              
  330.       CALL FILES(-1*RIO,BUF)                
  331.       LPT(1) = LIN(K+1)                   
  332.       LPT(4) = LIN(K+2)                   
  333.       LPT(6) = LIN(K+3)                   
  334.       PTZ = LIN(K+4)   
  335.       RIO = LIN(K+5)   
  336.       LCT(4) = LIN(K+6)                   
  337.       CHAR = BLANK     
  338.       SYM = COMMA      
  339.       GO TO 99         
  340. C                      
  341. C     LALA             
  342.    46 WRITE(WTE,146)   
  343.   146 FORMAT(1X,'QUIT SINGING AND GET BACK TO WORK.')        
  344.       GO TO 98         
  345. C                      
  346. C     FOO              
  347.    48 WRITE(WTE,148)   
  348.   148 FORMAT(1X,'YOUR PLACE OR MINE')     
  349.       GO TO 98         
  350. C                      
  351. C     SHORT, LONG      
  352.    50 FMT = 1          
  353.       GO TO 54         
  354.    52 FMT = 2          
  355.    54 IF (CHAR.EQ.E .OR. CHAR.EQ.D) FMT = FMT+2              
  356.       IF (CHAR .EQ. Z) FMT = 5            
  357.       IF (CHAR.EQ.E .OR. CHAR.EQ.D .OR. CHAR.EQ.Z) CALL GETSYM                  
  358.       GO TO 98         
  359. C                      
  360. C     SEMI             
  361.    55 LCT(3) = 1 - LCT(3)                 
  362.       GO TO 98         
  363. C                      
  364. C     WHO              
  365.    60 WRITE(WTE,160)   
  366.       IF (WIO .NE. 0) WRITE(WIO,160)      
  367.   160 FORMAT(1X,'Your current variables are...')             
  368.       CALL PRNTID(IDSTK(1,BOT),LSIZE-BOT+1)                  
  369.       L = VSIZE-LSTK(BOT)+1               
  370.       WRITE(WTE,161) L,VSIZE              
  371.       IF (WIO .NE. 0) WRITE(WIO,161) L,VSIZE                 
  372.   161 FORMAT(1X,'using ',I7,' out of ',I7,' elements.')      
  373.       GO TO 98         
  374. C                      
  375. C     WHAT             
  376.    65 WRITE(WTE,165)   
  377.   165 FORMAT(1X,'The functions and commands are...')         
  378.       H(1) = 0         
  379.       CALL FUNS(H)     
  380.       CALL PRNTID(CMD,CMDL-2)             
  381.       GO TO 98         
  382. C                      
  383. C     WHY              
  384.    70 K = IDINT(9.0D0*URAND(RAN(1))+1.0D0)                   
  385.       GO TO (71,72,73,74,75,76,77,78,79),K                   
  386.    71 WRITE(WTE,171)   
  387.   171 FORMAT(1X,'WHAT?')                  
  388.       GO TO 98         
  389.    72 WRITE(WTE,172)   
  390.   172 FORMAT(1X,'R.T.F.M.')               
  391.       GO TO 98         
  392.    73 WRITE(WTE,173)   
  393.   173 FORMAT(1X,'HOW THE HELL SHOULD I KNOW?')               
  394.       GO TO 98         
  395.    74 WRITE(WTE,174)   
  396.   174 FORMAT(1X,'PETE MADE ME DO IT.')    
  397.       GO TO 98         
  398.    75 WRITE(WTE,175)   
  399.   175 FORMAT(1X,'INSUFFICIENT DATA TO ANSWER.')              
  400.       GO TO 98         
  401.    76 WRITE(WTE,176)   
  402.   176 FORMAT(1X,'IT FEELS GOOD.')         
  403.       GO TO 98         
  404.    77 WRITE(WTE,177)   
  405.   177 FORMAT(1X,'WHY NOT?')               
  406.       GO TO 98         
  407.    78 WRITE(WTE,178)   
  408.   178 FORMAT(1X,'/--ERROR'/1X,'STUPID QUESTION.')            
  409.       GO TO 98         
  410.    79 WRITE(WTE,179)   
  411.   179 FORMAT(1X,'SYSTEM ERROR, RETRY')    
  412.       GO TO 98         
  413. C                      
  414. C     HELP             
  415.    80 IF (CHAR .NE. EOL) GO TO 81         
  416.       WRITE(WTE,180)   
  417.       IF (WIO .NE. 0) WRITE(WIO,180)      
  418.   180 FORMAT(1X,'Type HELP followed by ...'                  
  419.      $  /1X,'INTRO   (To get started)'    
  420.      $  /1X,'NEWS    (recent revisions)')                    
  421.       H(1) = 0         
  422.       CALL FUNS(H)     
  423.       CALL PRNTID(CMD,CMDL-2)             
  424.       J = BLANK+2      
  425.       WRITE(WTE,181)   
  426.       IF (WIO .NE. 0) WRITE(WIO,181)      
  427.   181 FORMAT(1X,'ANS   EDIT  FILE  FUN   MACRO')             
  428.       WRITE(WTE,182) (ALFA(I),I=J,ALFL)   
  429.       IF (WIO .NE. 0) WRITE(WIO,182) (ALFA(I),I=J,ALFL)      
  430.   182 FORMAT(1X,17(A1,1X)/)               
  431.       GO TO 98         
  432. C                      
  433.    81 CALL GETSYM      
  434.       IF (SYM .EQ. NAME) GO TO 82         
  435.       IF (SYM .EQ. 0) SYM = DOT           
  436.       H(1) = ALFA(SYM+1)                  
  437.       H(2) = ALFA(BLANK+1)                
  438.       H(3) = ALFA(BLANK+1)                
  439.       H(4) = ALFA(BLANK+1)                
  440.       GO TO 84         
  441.    82 DO 83 I = 1, 4   
  442.         CH = SYN(I)    
  443.         H(I) = ALFA(CH+1)                 
  444.    83 CONTINUE         
  445.    
  446.    84 IF(HIO .NE. 0) THEN
  447.       READ(HIO,101,END=89) (BUF(I),I=1,LRECL)                
  448. CDC.. IF (EOF(HIO).NE.0) GO TO 89         
  449.       DO 85 I = 1, 4   
  450.         IF (H(I) .NE. BUF(I)) GO TO 84    
  451.    85 CONTINUE         
  452.       WRITE(WTE,102)   
  453.       IF (WIO .NE. 0) WRITE(WIO,102)      
  454.    86 K = LRECL + 1    
  455.    87 K = K - 1        
  456.       IF (BUF(K) .EQ. ALFA(BLANK+1)) GO TO 87                
  457.       WRITE(WTE,102) (BUF(I),I=1,K)       
  458.       IF (WIO .NE. 0) WRITE(WIO,102) (BUF(I),I=1,K)          
  459.       READ(HIO,101) (BUF(I),I=1,LRECL)    
  460.       IF (BUF(1) .EQ. ALFA(BLANK+1)) GO TO 86                
  461.       CALL FILES(-HIO,BUF)                
  462.       GO TO 98 
  463.       ENDIF        
  464. C                      
  465.    89 WRITE(WTE,189) (H(I),I=1,4)         
  466.   189 FORMAT(1X,'SORRY, NO HELP ON ',4A1)                    
  467.       CALL FILES(-HIO,BUF)                
  468.       GO TO 98         
  469. C                      
  470.    98 CALL GETSYM      
  471.    99 RETURN           
  472.       END
  473.              
  474.       SUBROUTINE EDIT(BUF,N)              
  475.       INTEGER BUF(N)   
  476. C                      
  477. C     CALLED AFTER INPUT OF A SINGLE BACKSLASH               
  478. C     BUF CONTAINS PREVIOUS INPUT LINE, ONE CHAR PER WORD    
  479. C     ENTER LOCAL EDITOR IF AVAILABLE     
  480. C     OTHERWISE JUST   
  481.       RETURN           
  482.       END              
  483.               
  484.       SUBROUTINE ERROR(N)                 
  485.       INTEGER N        
  486.       DOUBLE PRECISION STKR(5005),STKI(5005)                 
  487.       INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP        
  488.       INTEGER IDS(4,32),PSTK(32),RSTK(32),PSIZE,PT,PTZ       
  489.       INTEGER ALFA(52),ALFB(52),ALFL,CASE                    
  490.       INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE           
  491.       INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)            
  492.       COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP          
  493.       COMMON /RECU/ IDS,PSTK,RSTK,PSIZE,PT,PTZ               
  494.       COMMON /ALFS/ ALFA,ALFB,ALFL,CASE   
  495.       COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE                  
  496.       COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN  
  497.       INTEGER ERRMSG(8),BLH,BEL           
  498.       DATA ERRMSG /1H/,1H-,1H-,1HE,1HR,1HR,1HO,1HR/,BLH/1H /,BEL/1H /           
  499. C     SET BEL TO CTRL-G IF POSSIBLE       
  500. C                      
  501.       K = LPT(2) - LPT(1)                 
  502.       IF (K .LT. 1) K = 1                 
  503.       LUNIT = WTE      
  504.    98 WRITE(LUNIT,100) (BLH,I=1,K),(ERRMSG(I),I=1,8),BEL     
  505.   100 FORMAT(1X,80A1)                     
  506.       GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,          
  507.      $      23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40),N            
  508. C                      
  509.     1 WRITE(LUNIT,101)                    
  510.   101 FORMAT(1X,'IMPROPER MULTIPLE ASSIGNMENT')              
  511.       GO TO 99         
  512.     2 WRITE(LUNIT,102)                    
  513.   102 FORMAT(1X,'IMPROPER FACTOR')        
  514.       GO TO 99         
  515.     3 WRITE(LUNIT,103)                    
  516.   103 FORMAT(1X,'EXPECT RIGHT PARENTHESIS')                  
  517.       GO TO 99         
  518.     4 DO 94 I = 1, 4   
  519.          K = IDS(I,PT+1)                  
  520.          BUF(I) = ALFA(K+1)               
  521.    94 CONTINUE         
  522.       WRITE(LUNIT,104) (BUF(I),I=1,4)     
  523.   104 FORMAT(1X,'UNDEFINED VARIABLE: ',4A1)                  
  524.       GO TO 99         
  525.     5 WRITE(LUNIT,105)                    
  526.   105 FORMAT(1X,'COLUMN LENGTHS DO NOT MATCH')               
  527.       GO TO 99         
  528.     6 WRITE(LUNIT,106)                    
  529.   106 FORMAT(1X,'ROW LENGTHS DO NOT MATCH')                  
  530.       GO TO 99         
  531.     7 WRITE(LUNIT,107)                    
  532.   107 FORMAT(1X,'TEXT TOO LONG')          
  533.       GO TO 99         
  534.     8 WRITE(LUNIT,108)                    
  535.   108 FORMAT(1X,'INCOMPATIBLE FOR ADDITION')                 
  536.       GO TO 99         
  537.     9 WRITE(LUNIT,109)                    
  538.   109 FORMAT(1X,'INCOMPATIBLE FOR SUBTRACTION')              
  539.       GO TO 99         
  540.    10 WRITE(LUNIT,110)                    
  541.   110 FORMAT(1X,'INCOMPATIBLE FOR MULTIPLICATION')           
  542.        GO TO 99        
  543.    11 WRITE(LUNIT,111)                    
  544.   111 FORMAT(1X,'INCOMPATIBLE FOR RIGHT DIVISION')           
  545.       GO TO 99         
  546.    12 WRITE(LUNIT,112)                    
  547.   112 FORMAT(1X,'INCOMPATIBLE FOR LEFT DIVISION')            
  548.       GO TO 99         
  549.    13 WRITE(LUNIT,113)                    
  550.   113 FORMAT(1X,'IMPROPER ASSIGNMENT TO PERMANENT VARIABLE') 
  551.       GO TO 99         
  552.    14 WRITE(LUNIT,114)                    
  553.   114 FORMAT(1X,'EYE-DENTITY UNDEFINED BY CONTEXT')          
  554.       GO TO 99         
  555.    15 WRITE(LUNIT,115)                    
  556.   115 FORMAT(1X,'IMPROPER ASSIGNMENT TO SUBMATRIX')          
  557.       GO TO 99         
  558.    16 WRITE(LUNIT,116)                    
  559.   116 FORMAT(1X,'IMPROPER COMMAND')       
  560.       GO TO 99         
  561.    17 LB = VSIZE - LSTK(BOT) + 1          
  562.       LT = ERR + LSTK(BOT)                
  563.       WRITE(LUNIT,117) LB,LT,VSIZE        
  564.   117 FORMAT(1X,'TOO MUCH MEMORY REQUIRED'                   
  565.      $  /1X,' ',I7,' VARIABLES,',I7,' TEMPORARIES,',I7,' AVAILABLE.')           
  566.       GO TO 99         
  567.    18 WRITE(LUNIT,118)                    
  568.   118 FORMAT(1X,'TOO MANY NAMES')         
  569.       GO TO 99         
  570.    19 WRITE(LUNIT,119)                    
  571.   119 FORMAT(1X,'MATRIX IS SINGULAR TO WORKING PRECISION')   
  572.       GO TO 99         
  573.    20 WRITE(LUNIT,120)                    
  574.   120 FORMAT(1X,'MATRIX MUST BE SQUARE')  
  575.       GO TO 99         
  576.    21 WRITE(LUNIT,121)                    
  577.   121 FORMAT(1X,'SUBSCRIPT OUT OF RANGE')                    
  578.       GO TO 99         
  579.    22 WRITE(LUNIT,122) (RSTK(I),I=1,PT)   
  580.   122 FORMAT(1X,'RECURSION DIFFICULTIES',10I4)               
  581.       GO TO 99         
  582.    23 WRITE(LUNIT,123)                    
  583.   123 FORMAT(1X,'ONLY 1, 2 OR INF NORM OF MATRIX')           
  584.       GO TO 99         
  585.    24 WRITE(LUNIT,124)                    
  586.   124 FORMAT(1X,'NO CONVERGENCE')         
  587.       GO TO 99         
  588.    25 WRITE(LUNIT,125)                    
  589.   125 FORMAT(1X,'CAN NOT USE FUNCTION NAME AS VARIABLE')     
  590.       GO TO 99         
  591.    26 WRITE(LUNIT,126)                    
  592.   126 FORMAT(1X,'TOO COMPLICATED (STACK OVERFLOW)')          
  593.       GO TO 99         
  594.    27 WRITE(LUNIT,127)                    
  595.   127 FORMAT(1X,'DIVISION BY ZERO IS A NO-NO')               
  596.       GO TO 99         
  597.    28 WRITE(LUNIT,128)                    
  598.   128 FORMAT(1X,'EMPTY MACRO')            
  599.       GO TO 99         
  600.    29 WRITE(LUNIT,129)                    
  601.   129 FORMAT(1X,'NOT POSITIVE DEFINITE')  
  602.       GO TO 99         
  603.    30 WRITE(LUNIT,130)                    
  604.   130 FORMAT(1X,'IMPROPER EXPONENT')      
  605.       GO TO 99         
  606.    31 WRITE(LUNIT,131)                    
  607.   131 FORMAT(1X,'IMPROPER STRING')        
  608.       GO TO 99         
  609.    32 WRITE(LUNIT,132)                    
  610.   132 FORMAT(1X,'SINGULARITY OF LOG OR ATAN')                
  611.       GO TO 99         
  612.    33 WRITE(LUNIT,133)                    
  613.   133 FORMAT(1X,'TOO MANY COLONS')        
  614.       GO TO 99         
  615.    34 WRITE(LUNIT,134)                    
  616.   134 FORMAT(1X,'IMPROPER FOR CLAUSE')    
  617.       GO TO 99         
  618.    35 WRITE(LUNIT,135)                    
  619.   135 FORMAT(1X,'IMPROPER WHILE OR IF CLAUSE')               
  620.       GO TO 99         
  621.    36 WRITE(LUNIT,136)                    
  622.   136 FORMAT(1X,'ARGUMENT OUT OF RANGE')  
  623.       GO TO 99         
  624.    37 WRITE(LUNIT,137)                    
  625.   137 FORMAT(1X,'IMPROPER MACRO')         
  626.       GO TO 99         
  627.    38 WRITE(LUNIT,138)                    
  628.   138 FORMAT(1X,'IMPROPER FILE NAME')     
  629.       GO TO 99         
  630.    39 WRITE(LUNIT,139)                    
  631.   139 FORMAT(1X,'INCORRECT NUMBER OF ARGUMENTS')             
  632.       GO TO 99         
  633.    40 WRITE(LUNIT,140)                    
  634.   140 FORMAT(1X,'EXPECT STATEMENT TERMINATOR')               
  635.       GO TO 99         
  636. C                      
  637.    99 ERR = N          
  638.       IF (LUNIT.EQ.WIO .OR. WIO.EQ.0) RETURN                 
  639.       LUNIT = WIO      
  640.       GO TO 98         
  641.       END
  642.       SUBROUTINE EXPR                     
  643.       DOUBLE PRECISION STKR(5005),STKI(5005)                 
  644.       INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP        
  645.       INTEGER IDS(4,32),PSTK(32),RSTK(32),PSIZE,PT,PTZ       
  646.       INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE           
  647.       INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)            
  648.       COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP          
  649.       COMMON /RECU/ IDS,PSTK,RSTK,PSIZE,PT,PTZ               
  650.       COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE                  
  651.       COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN  
  652.       INTEGER OP,R,BLANK,SIGN,PLUS,MINUS,NAME,COLON,EYE(4)   
  653.       DATA COLON/40/,BLANK/36/,PLUS/41/,MINUS/42/,NAME/1/    
  654.       DATA EYE/14,34,14,36/               
  655.       IF (DDT .EQ. 1) WRITE(WTE,100) PT,RSTK(PT)             
  656.   100 FORMAT(1X,'EXPR  ',2I4)             
  657.       R = RSTK(PT)     
  658.       GO TO (01,01,01,01,01,05,25,99,99,01,01,99,99,99,99,99,99,01,01,          
  659.      $       01),R     
  660.    01 IF (SYM .EQ. COLON) CALL PUTID(SYN,EYE)                
  661.       IF (SYM .EQ. COLON) SYM = NAME      
  662.       KOUNT = 1        
  663.    02 SIGN = PLUS      
  664.       IF (SYM .EQ. MINUS) SIGN = MINUS    
  665.       IF (SYM.EQ.PLUS .OR. SYM.EQ.MINUS) CALL GETSYM         
  666.       PT = PT+1        
  667.       IF (PT .GT. PSIZE-1) CALL ERROR(26)                    
  668.       IF (ERR .GT. 0) RETURN              
  669.       PSTK(PT) = SIGN + 256*KOUNT         
  670.       RSTK(PT) = 6     
  671. C     *CALL* TERM      
  672.       RETURN           
  673.    05 SIGN = MOD(PSTK(PT),256)            
  674.       KOUNT = PSTK(PT)/256                
  675.       PT = PT-1        
  676.       IF (SIGN .EQ. MINUS) CALL STACK1(MINUS)                
  677.       IF (ERR .GT. 0) RETURN              
  678.    10 IF (SYM.EQ.PLUS .OR. SYM.EQ.MINUS) GO TO 20            
  679.       GO TO 50         
  680.    20 IF (RSTK(PT) .NE. 10) GO TO 21      
  681. C     BLANK IS DELIMITER INSIDE ANGLE BRACKETS               
  682.       LS = LPT(3) - 2                     
  683.       IF (LIN(LS) .EQ. BLANK) GO TO 50    
  684.    21 OP = SYM         
  685.       CALL GETSYM      
  686.       PT = PT+1        
  687.       PSTK(PT) = OP + 256*KOUNT           
  688.       RSTK(PT) = 7     
  689. C     *CALL* TERM      
  690.       RETURN           
  691.    25 OP = MOD(PSTK(PT),256)              
  692.       KOUNT = PSTK(PT)/256                
  693.       PT = PT-1        
  694.       CALL STACK2(OP)                     
  695.       IF (ERR .GT. 0) RETURN              
  696.       GO TO 10         
  697.    50 IF (SYM .NE. COLON) GO TO 60        
  698.       CALL GETSYM      
  699.       KOUNT = KOUNT+1                     
  700.       GO TO 02         
  701.    60 IF (KOUNT .GT. 3) CALL ERROR(33)    
  702.       IF (ERR .GT. 0) RETURN              
  703.       RHS = KOUNT      
  704.       IF (KOUNT .GT. 1) CALL STACK2(COLON)                   
  705.       IF (ERR .GT. 0) RETURN              
  706.       RETURN           
  707.    99 CALL ERROR(22)   
  708.       IF (ERR .GT. 0) RETURN              
  709.       RETURN           
  710.       END
  711.               
  712.       SUBROUTINE FACTOR                   
  713.       DOUBLE PRECISION STKR(5005),STKI(5005)                 
  714.       INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP        
  715.       INTEGER IDS(4,32),PSTK(32),RSTK(32),PSIZE,PT,PTZ       
  716.       INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE           
  717.       INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)            
  718.       COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP          
  719.       COMMON /RECU/ IDS,PSTK,RSTK,PSIZE,PT,PTZ               
  720.       COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE                  
  721.       COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN  
  722.       INTEGER SEMI,EOL,BLANK,R,ID(4),EXCNT,LPAREN,RPAREN     
  723.       INTEGER STAR,DSTAR,COMMA,LESS,GREAT,QUOTE,NUM,NAME,ALFL                   
  724.       DATA DSTAR/54/,SEMI/39/,EOL/99/,BLANK/36/              
  725.       DATA STAR/43/,COMMA/48/,LPAREN/37/,RPAREN/38/          
  726.       DATA LESS/50/,GREAT/51/,QUOTE/49/,NUM/0/,NAME/1/,ALFL/52/                 
  727.       IF (DDT .EQ. 1) WRITE(WTE,100) PT,RSTK(PT),SYM         
  728.   100 FORMAT(1X,'FACTOR',3I4)             
  729.       R = RSTK(PT)     
  730.       GO TO (99,99,99,99,99,99,99,01,01,25,45,65,99,99,99,55,75,32,37),R        
  731.    01 IF (SYM.EQ.NUM .OR. SYM.EQ.QUOTE .OR.  SYM.EQ.LESS) GO TO 10              
  732.       IF (SYM .EQ. GREAT) GO TO 30        
  733.       EXCNT = 0        
  734.       IF (SYM .EQ. NAME) GO TO 40         
  735.       ID(1) = BLANK    
  736.       IF (SYM .EQ. LPAREN) GO TO 42       
  737.       CALL ERROR(2)    
  738.       IF (ERR .GT. 0) RETURN              
  739. C                      
  740. C     PUT SOMETHING ON THE STACK          
  741.    10 L = 1            
  742.       IF (TOP .GT. 0) L = LSTK(TOP) + MSTK(TOP)*NSTK(TOP)    
  743.       IF (TOP+1 .GE. BOT) CALL ERROR(18)  
  744.       IF (ERR .GT. 0) RETURN              
  745.       TOP = TOP+1      
  746.       LSTK(TOP) = L    
  747.       IF (SYM .EQ. QUOTE) GO TO 15        
  748.       IF (SYM .EQ. LESS) GO TO 20         
  749. C                      
  750. C     SINGLE NUMBER, GETSYM STORED IT IN STKI                
  751.       MSTK(TOP) = 1    
  752.       NSTK(TOP) = 1    
  753.       STKR(L) = STKI(VSIZE)               
  754.       STKI(L) = 0.0D0                     
  755.       CALL GETSYM      
  756.       GO TO 60         
  757. C                      
  758. C     STRING           
  759.    15 N = 0            
  760.       LPT(4) = LPT(3)                     
  761.       CALL GETCH       
  762.    16 IF (CHAR .EQ. QUOTE) GO TO 18       
  763.    17 LN = L+N         
  764.       IF (CHAR .EQ. EOL) CALL ERROR(31)   
  765.       IF (ERR .GT. 0) RETURN              
  766.       STKR(LN) = DFLOAT(CHAR)             
  767.       STKI(LN) = 0.0D0                    
  768.       N = N+1          
  769.       CALL GETCH       
  770.       GO TO 16         
  771.    18 CALL GETCH       
  772.       IF (CHAR .EQ. QUOTE) GO TO 17       
  773.       IF (N .LE. 0) CALL ERROR(31)        
  774.       IF (ERR .GT. 0) RETURN              
  775.       MSTK(TOP) = 1    
  776.       NSTK(TOP) = N    
  777.       CALL GETSYM      
  778.       GO TO 60         
  779. C                      
  780. C     EXPLICIT MATRIX                     
  781.    20 MSTK(TOP) = 0    
  782.       NSTK(TOP) = 0    
  783.    21 TOP = TOP + 1    
  784.       LSTK(TOP) = LSTK(TOP-1) + MSTK(TOP-1)*NSTK(TOP-1)      
  785.       MSTK(TOP) = 0    
  786.       NSTK(TOP) = 0    
  787.       CALL GETSYM      
  788.    22 IF (SYM.EQ.SEMI .OR. SYM.EQ.GREAT .OR. SYM.EQ.EOL) GO TO 27               
  789.       IF (SYM .EQ. COMMA) CALL GETSYM     
  790.       PT = PT+1        
  791.       RSTK(PT) = 10    
  792. C     *CALL* EXPR      
  793.       RETURN           
  794.    25 PT = PT-1        
  795.       TOP = TOP - 1    
  796.       IF (MSTK(TOP) .EQ. 0) MSTK(TOP) = MSTK(TOP+1)          
  797.       IF (MSTK(TOP) .NE. MSTK(TOP+1)) CALL ERROR(5)          
  798.       IF (ERR .GT. 0) RETURN              
  799.       NSTK(TOP) = NSTK(TOP) + NSTK(TOP+1)                    
  800.       GO TO 22         
  801.    27 IF (SYM.EQ.SEMI .AND. CHAR.EQ.EOL) CALL GETSYM         
  802.       CALL STACK1(QUOTE)                  
  803.       IF (ERR .GT. 0) RETURN              
  804.       TOP = TOP - 1    
  805.       IF (MSTK(TOP) .EQ. 0) MSTK(TOP) = MSTK(TOP+1)          
  806.       IF (MSTK(TOP).NE.MSTK(TOP+1) .AND. MSTK(TOP+1).GT.0) CALL ERROR(6)        
  807.       IF (ERR .GT. 0) RETURN              
  808.       NSTK(TOP) = NSTK(TOP) + NSTK(TOP+1)                    
  809.       IF (SYM .EQ. EOL) CALL GETLIN       
  810.       IF (SYM .NE. GREAT) GO TO 21        
  811.       CALL STACK1(QUOTE)                  
  812.       IF (ERR .GT. 0) RETURN              
  813.       CALL GETSYM      
  814.       GO TO 60         
  815. C                      
  816. C     MACRO STRING     
  817.    30 CALL GETSYM      
  818.       IF (SYM.EQ.LESS .AND. CHAR.EQ.EOL) CALL ERROR(28)      
  819.       IF (ERR .GT. 0) RETURN              
  820.       PT = PT+1        
  821.       RSTK(PT) = 18    
  822. C     *CALL* EXPR      
  823.       RETURN           
  824.    32 PT = PT-1        
  825.       IF (SYM.NE.LESS .AND. SYM.NE.EOL) CALL ERROR(37)       
  826.       IF (ERR .GT. 0) RETURN              
  827.       IF (SYM .EQ. LESS) CALL GETSYM      
  828.       K = LPT(6)       
  829.       LIN(K+1) = LPT(1)                   
  830.       LIN(K+2) = LPT(2)                   
  831.       LIN(K+3) = LPT(6)                   
  832.       LPT(1) = K + 4   
  833. C     TRANSFER STACK TO INPUT LINE        
  834.       K = LPT(1)       
  835.       L = LSTK(TOP)    
  836.       N = MSTK(TOP)*NSTK(TOP)             
  837.       DO 34 J = 1, N   
  838.          LS = L + J-1                     
  839.          LIN(K) = IDINT(STKR(LS))         
  840.          IF (LIN(K).LT.0 .OR. LIN(K).GE.ALFL) CALL ERROR(37) 
  841.          IF (ERR .GT. 0) RETURN           
  842.          IF (K.LT.1024) K = K+1           
  843.          IF (K.EQ.1024) WRITE(WTE,33) K   
  844.    33    FORMAT(1X,'INPUT BUFFER LIMIT IS ',I4,' CHARACTERS.')                  
  845.    34 CONTINUE         
  846.       TOP = TOP-1      
  847.       LIN(K) = EOL     
  848.       LPT(6) = K       
  849.       LPT(4) = LPT(1)                     
  850.       LPT(3) = 0       
  851.       LPT(2) = 0       
  852.       LCT(1) = 0       
  853.       CHAR = BLANK     
  854.       CALL GETSYM      
  855.       PT = PT+1        
  856.       RSTK(PT) = 19    
  857. C     *CALL* EXPR      
  858.       RETURN           
  859.    37 PT = PT-1        
  860.       K = LPT(1) - 4   
  861.       LPT(1) = LIN(K+1)                   
  862.       LPT(4) = LIN(K+2)                   
  863.       LPT(6) = LIN(K+3)                   
  864.       CHAR = BLANK     
  865.       CALL GETSYM      
  866.       GO TO 60         
  867. C                      
  868. C     FUNCTION OR MATRIX ELEMENT          
  869.    40 CALL PUTID(ID,SYN)                  
  870.       CALL GETSYM      
  871.       IF (SYM .EQ. LPAREN) GO TO 42       
  872.       RHS = 0          
  873.       CALL FUNS(ID)    
  874.       IF (FIN .NE. 0) CALL ERROR(25)      
  875.       IF (ERR .GT. 0) RETURN              
  876.       CALL STACKG(ID)                     
  877.       IF (ERR .GT. 0) RETURN              
  878.       IF (FIN .EQ. 7) GO TO 50            
  879.       IF (FIN .EQ. 0) CALL PUTID(IDS(1,PT+1),ID)             
  880.       IF (FIN .EQ. 0) CALL ERROR(4)       
  881.       IF (ERR .GT. 0) RETURN              
  882.       GO TO 60         
  883. C                      
  884.    42 CALL GETSYM      
  885.       EXCNT = EXCNT+1                     
  886.       PT = PT+1        
  887.       PSTK(PT) = EXCNT                    
  888.       CALL PUTID(IDS(1,PT),ID)            
  889.       RSTK(PT) = 11    
  890. C     *CALL* EXPR      
  891.       RETURN           
  892.    45 CALL PUTID(ID,IDS(1,PT))            
  893.       EXCNT = PSTK(PT)                    
  894.       PT = PT-1        
  895.       IF (SYM .EQ. COMMA) GO TO 42        
  896.       IF (SYM .NE. RPAREN) CALL ERROR(3)  
  897.       IF (ERR .GT. 0) RETURN              
  898.       IF (SYM .EQ. RPAREN) CALL GETSYM    
  899.       IF (ID(1) .EQ. BLANK) GO TO 60      
  900.       RHS = EXCNT      
  901.       CALL STACKG(ID)                     
  902.       IF (ERR .GT. 0) RETURN              
  903.       IF (FIN .EQ. 0) CALL FUNS(ID)       
  904.       IF (FIN .EQ. 0) CALL ERROR(4)       
  905.       IF (ERR .GT. 0) RETURN              
  906. C                      
  907. C     EVALUATE MATRIX FUNCTION            
  908.    50 PT = PT+1        
  909.       RSTK(PT) = 16    
  910. C     *CALL* MATFN     
  911.       RETURN           
  912.    55 PT = PT-1        
  913.       GO TO 60         
  914. C                      
  915. C     CHECK FOR QUOTE (TRANSPOSE) AND ** (POWER)             
  916.    60 IF (SYM .NE. QUOTE) GO TO 62        
  917.          I = LPT(3) - 2                   
  918.          IF (LIN(I) .EQ. BLANK) GO TO 90  
  919.          CALL STACK1(QUOTE)               
  920.          IF (ERR .GT. 0) RETURN           
  921.          CALL GETSYM   
  922.    62 IF (SYM.NE.STAR .OR. CHAR.NE.STAR) GO TO 90            
  923.       CALL GETSYM      
  924.       CALL GETSYM      
  925.       PT = PT+1        
  926.       RSTK(PT) = 12    
  927. C     *CALL* FACTOR    
  928.       GO TO 01         
  929.    65 PT = PT-1        
  930.       CALL STACK2(DSTAR)                  
  931.       IF (ERR .GT. 0) RETURN              
  932.       IF (FUN .NE. 2) GO TO 90            
  933. C     MATRIX POWER, USE EIGENVECTORS      
  934.       PT = PT+1        
  935.       RSTK(PT) = 17    
  936. C     *CALL* MATFN     
  937.       RETURN           
  938.    75 PT = PT-1        
  939.    90 RETURN           
  940.    99 CALL ERROR(22)   
  941.       IF (ERR .GT. 0) RETURN              
  942.       RETURN           
  943.       END
  944.               
  945.       SUBROUTINE FILES(LUNIT,NAME)        
  946.       INTEGER LUNIT              
  947. C                      
  948. C     AMIGA SPECIFIC ROUTINE TO ALLOCATE FILES             
  949. C     LUNIT = LOGICAL UNIT NUMBER         
  950. C     NAME = FILE NAME, 1 CHARACTER PER WORD                 
  951. C                      
  952.       character*1024 NAME
  953.       INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE       
  954.       COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE              
  955. C                      
  956. C  Amiga dependent stuff to squeeze the NAME from one char per word to one
  957. C  per byte
  958. C
  959.       character*1024 NAME2
  960.       integer*1 strip(4,256),strip2(32)
  961.       character*32 NAME3
  962.       equivalence (NAME2,strip),(NAME3,strip2)
  963. C
  964.       FE=0
  965. C
  966. C ERROR CATCHER
  967.       IF (LUNIT .EQ. 0) RETURN 
  968. C
  969. C PRINTER
  970.       if (LUNIT .eq. 6) return 
  971. C
  972. C TERMINAL I/O
  973.       if (LUNIT .eq. 9) return           
  974. C
  975. C HELP FILE
  976.       if (LUNIT .eq. 11) then              
  977.       OPEN(11,FILE='HELP.LIS',STATUS='OLD',ERR=14)
  978.          write(9,09)   
  979.    09    format(/1X,'HELP is available')  
  980.          return        
  981.       end if           
  982.       if (LUNIT .eq. -11 .AND. HIO .NE. 0) then             
  983.          rewind (11,ERR=99)      
  984.          return        
  985.       end if           
  986.       if (LUNIT .lt. 0) then              
  987.          close(unit=-LUNIT,ERR=99)               
  988.          return        
  989.       end if           
  990.    10 continue
  991. C
  992. C  ALL OTHER FILES
  993. C
  994.       NAME2=NAME
  995.       do 37 j=1,32
  996.    37 strip2(j)=strip(1,j)     
  997.       OPEN(UNIT=LUNIT,FILE=NAME3,STATUS='UNKNOWN',ERR=98) 
  998.       RETURN
  999.    14 WRITE(9,15)
  1000. C
  1001. C HELP FILE NOT FOUND
  1002. C
  1003.    15 FORMAT(1X,'HELP IS NOT AVAILABLE')
  1004.       HIO = 0
  1005.       RETURN           
  1006. C
  1007. C GENERAL FILE OPEN FAILURE
  1008. C
  1009.    98 WRITE(9,16)
  1010.    16 FORMAT(1X,'OPEN FILE FAILED')
  1011.       FE=1
  1012.  
  1013. C IF THIS WAS A DIARY FILE (OUTPUT), SET ITS FILE HANDLE TO 0 
  1014.  
  1015.       IF(LUNIT .EQ. 8) THEN
  1016.         WIO=0
  1017. C
  1018. C OTHERWISE, SET THE I/O TO TERMINAL I/O
  1019. C
  1020.       ELSE
  1021.         RIO=RTE
  1022.       ENDIF
  1023.       RETURN
  1024.    99 CONTINUE
  1025.       RETURN
  1026.       END              
  1027.                 
  1028.       DOUBLE PRECISION FUNCTION FLOP(X)   
  1029.       DOUBLE PRECISION X                  
  1030. C     SYSTEM DEPENDENT FUNCTION           
  1031. C     COUNT AND POSSIBLY CHOP EACH FLOATING POINT OPERATION  
  1032. C     FLP(1) IS FLOP COUNTER              
  1033. C     FLP(2) IS NUMBER OF PLACES TO BE CHOPPED               
  1034. C                      
  1035.       INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)            
  1036.       COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN  
  1037. C                      
  1038.       DOUBLE PRECISION MASK(14),XX,MM     
  1039.       real mas(2,14)   
  1040.       LOGICAL LX(2),LM(2)                 
  1041.       EQUIVALENCE (LX(1),XX),(LM(1),MM)   
  1042.       equivalence (MASK(1),mas(1))        
  1043.       data mas/        
  1044.      $ Z'ffffffff',Z'fff0ffff',           
  1045.      $ Z'ffffffff',Z'ff00ffff',           
  1046.      $ Z'ffffffff',Z'f000ffff',           
  1047.      $ Z'ffffffff',Z'0000ffff',           
  1048.      $ Z'ffffffff',Z'0000fff0',           
  1049.      $ Z'ffffffff',Z'0000ff00',           
  1050.      $ Z'ffffffff',Z'0000f000',           
  1051.      $ Z'ffffffff',Z'00000000',           
  1052.      $ Z'fff0ffff',Z'00000000',           
  1053.      $ Z'ff00ffff',Z'00000000',           
  1054.      $ Z'f000ffff',Z'00000000',           
  1055.      $ Z'0000ffff',Z'00000000',           
  1056.      $ Z'0000fff0',Z'00000000',           
  1057.      $ Z'0000ff80',Z'00000000'/           
  1058. C                      
  1059.       FLP(1) = FLP(1) + 1                 
  1060.       K = FLP(2)       
  1061.       FLOP = X         
  1062.       IF (K .LE. 0) RETURN                
  1063.       FLOP = 0.0D0     
  1064.       IF (K .GE. 15) RETURN               
  1065.       XX = X           
  1066.       MM = MASK(K)     
  1067.       LX(1) = LX(1) .AND. LM(1)           
  1068.       LX(2) = LX(2) .AND. LM(2)           
  1069.       FLOP = XX        
  1070.       RETURN           
  1071.       END
  1072.              
  1073.       SUBROUTINE FORMZ(LUNIT,X,Y)         
  1074.       DOUBLE PRECISION X,Y                
  1075. C                      
  1076. C     SYSTEM DEPENDENT ROUTINE TO PRINT WITH Z FORMAT        
  1077. C                      
  1078.       IF (Y .NE. 0.0D0) WRITE(LUNIT,10) X,Y                  
  1079.       IF (Y .EQ. 0.0D0) WRITE(LUNIT,10) X                    
  1080.    10 FORMAT(2Z18)     
  1081.       RETURN           
  1082.       END
  1083.               
  1084.       SUBROUTINE FUNS(ID)                 
  1085.       INTEGER ID(4)    
  1086. C                      
  1087. C     SCAN FUNCTION LIST                  
  1088. C                      
  1089.       DOUBLE PRECISION STKR(5005),STKI(5005)                 
  1090.       INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP        
  1091.       INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE           
  1092.       INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)            
  1093.       COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP          
  1094.       COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE                  
  1095.       COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN  
  1096.       LOGICAL EQID     
  1097.       INTEGER FUNL,FUNN(4,57),FUNP(57)    
  1098.       DATA FUNL/57/    
  1099. C                      
  1100. C    1  ABS   ATAN  BASE  CHAR            
  1101. C    2  CHOL  CHOP  COND  CONJ            
  1102. C    3  COS   DET   DIAG  DIAR            
  1103. C    4  DISP  EIG   EPS   EXEC            
  1104. C    5  EXP   EYE   FLOP  HESS            
  1105. C    6  HILB  IMAG  INV   KRON            
  1106. C    7  LINE  LOAD  LOG   LU              
  1107. C    8  MAGIC NORM  ONES  ORTH            
  1108. C    9  PINV  PLOT  POLY  PRINT           
  1109. C    $  PROD  QR    RAND  RANK            
  1110. C    1  RAT   RCOND REAL  ROOT            
  1111. C    2  ROUND RREF  SAVE  SCHUR           
  1112. C    3  SIN   SIZE  SQRT  SUM             
  1113. C    4  SVD   TRIL  TRIU  USER            
  1114. C    5  DEBUG          
  1115. C                      
  1116.       DATA FUNN/       
  1117.      1  10,11,28,36, 10,29,10,23, 11,10,28,14, 12,17,10,27,  
  1118.      2  12,17,24,21, 12,17,24,25, 12,24,23,13, 12,24,23,19,  
  1119.      3  12,24,28,36, 13,14,29,36, 13,18,10,16, 13,18,10,27,  
  1120.      4  13,18,28,25, 14,18,16,36, 14,25,28,36, 14,33,14,12,  
  1121.      5  14,33,25,36, 14,34,14,36, 15,21,24,25, 17,14,28,28,  
  1122.      6  17,18,21,11, 18,22,10,16, 18,23,31,36, 20,27,24,23,  
  1123.      7  21,18,23,14, 21,24,10,13, 21,24,16,36, 21,30,36,36,  
  1124.      8  22,10,16,18, 23,24,27,22, 24,23,14,28, 24,27,29,17,  
  1125.      9  25,18,23,31, 25,21,24,29, 25,24,21,34, 25,27,18,23,  
  1126.      $  25,27,24,13, 26,27,36,36, 27,10,23,13, 27,10,23,20,  
  1127.      1  27,10,29,36, 27,12,24,23, 27,14,10,21, 27,24,24,29,  
  1128.      2  27,24,30,23, 27,27,14,15, 28,10,31,14, 28,12,17,30,  
  1129.      3  28,18,23,36, 28,18,35,14, 28,26,27,29, 28,30,22,36,  
  1130.      4  28,31,13,36, 29,27,18,21, 29,27,18,30, 30,28,14,27,  
  1131.      5  13,14,11,30/   
  1132. C                      
  1133.       DATA FUNP/       
  1134.      1  221,203,507,509, 106,609,303,225, 202,102,602,505,   
  1135.      4  506,211,000,501, 204,606,000,213, 105,224,101,611,   
  1136.      7  508,503,206,104, 601,304,608,402, 302,510,214,504,   
  1137.      $  604,401,607,305, 511,103,223,215, 222,107,502,212,   
  1138.      3  201,610,205,603, 301,614,615,605, 512/               
  1139. C                      
  1140.       IF (ID(1).EQ.0) CALL PRNTID(FUNN,FUNL-1)               
  1141.       IF (ID(1).EQ.0) RETURN              
  1142. C                      
  1143.       DO 10 K = 1, FUNL                   
  1144.          IF (EQID(ID,FUNN(1,K))) GO TO 20                    
  1145.    10 CONTINUE         
  1146.       FIN = 0          
  1147.       RETURN           
  1148. C                      
  1149.    20 FIN = MOD(FUNP(K),100)              
  1150.       FUN = FUNP(K)/100                   
  1151.       IF (RHS.EQ.0 .AND. FUNP(K).EQ.606) FIN = 0             
  1152.       IF (RHS.EQ.0 .AND. FUNP(K).EQ.607) FIN = 0             
  1153.       RETURN           
  1154.       END
  1155.               
  1156.       SUBROUTINE GETCH                    
  1157. C     GET NEXT CHARACTER                  
  1158.       INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE           
  1159.       INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)            
  1160.       COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE                  
  1161.       COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN  
  1162.       INTEGER EOL      
  1163.       DATA EOL/99/     
  1164.       L = LPT(4)       
  1165.       CHAR = LIN(L)    
  1166.       IF (CHAR .NE. EOL) LPT(4) = L + 1   
  1167.       RETURN           
  1168.       END 
  1169.               
  1170.       SUBROUTINE GETLIN                   
  1171. C     GET A NEW LINE   
  1172.       INTEGER ALFA(52),ALFB(52),ALFL,CASE                    
  1173.       INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE           
  1174.       INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)            
  1175.       COMMON /ALFS/ ALFA,ALFB,ALFL,CASE   
  1176.       COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE                  
  1177.       COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN  
  1178.       INTEGER LRECL,EOL,SLASH,BSLASH,DOT,BLANK,RETU(4)       
  1179.       DATA EOL/99/,DOT/47/,BLANK/36/,RETU/27,14,29,30/       
  1180.       DATA SLASH/44/,BSLASH/45/,LRECL/80/                    
  1181. C                      
  1182.    10 L = LPT(1)       
  1183.    11 DO 12 J = 1, LRECL                  
  1184.          BUF(J) = ALFA(BLANK+1)           
  1185.    12 CONTINUE         
  1186.       READ(RIO,101,END=50,ERR=15) (BUF(J),J=1,LRECL)         
  1187. CDC.. IF (EOF(RIO).NE.0) GO TO 50         
  1188.   101 FORMAT(80A1)     
  1189.       N = LRECL+1      
  1190.    15 N = N-1          
  1191.       IF (BUF(N) .EQ. ALFA(BLANK+1)) GO TO 15                
  1192.       IF (MOD(LCT(4),2) .EQ. 1) WRITE(WTE,102) (BUF(J),J=1,N)                   
  1193.       IF (WIO .NE. 0) WRITE(WIO,102) (BUF(J),J=1,N)          
  1194.   102 FORMAT(1X,80A1)                     
  1195. C                      
  1196.       DO 40 J = 1, N   
  1197.          DO 20 K = 1, ALFL                
  1198.            IF (BUF(J).EQ.ALFA(K) .OR. BUF(J).EQ.ALFB(K)) GO TO 30               
  1199.    20    CONTINUE      
  1200.          K = EOL+1     
  1201.          CALL XCHAR(BUF(J),K)             
  1202.          IF (K .GT. EOL) GO TO 10         
  1203.          IF (K .EQ. EOL) GO TO 45         
  1204.          IF (K .EQ. -1) L = L-1           
  1205.          IF (K .LE. 0) GO TO 40           
  1206. C                      
  1207.    30    K = K-1       
  1208.          IF (K.EQ.SLASH .AND. BUF(J+1).EQ.BUF(J)) GO TO 45   
  1209.          IF (K.EQ.DOT .AND. BUF(J+1).EQ.BUF(J)) GO TO 11     
  1210.          IF (K.EQ.BSLASH .AND. N.EQ.1) GO TO 60              
  1211.          LIN(L) = K    
  1212.          IF (L.LT.1024) L = L+1           
  1213.          IF (L.EQ.1024) WRITE(WTE,33) L   
  1214.    33    FORMAT(1X,'INPUT BUFFER LIMIT IS ',I4,' CHARACTERS.')                  
  1215.    40 CONTINUE         
  1216.    45 LIN(L) = EOL     
  1217.       LPT(6) = L       
  1218.       LPT(4) = LPT(1)                     
  1219.       LPT(3) = 0       
  1220.       LPT(2) = 0       
  1221.       LCT(1) = 0       
  1222.       CALL GETCH       
  1223.       RETURN           
  1224. C                      
  1225.    50 IF (RIO .EQ. RTE) GO TO 52          
  1226.       CALL PUTID(LIN(L),RETU)             
  1227.       L = L + 4        
  1228.       GO TO 45         
  1229.    52 CALL FILES(-1*RTE,BUF)                
  1230.       LIN(L) = EOL     
  1231.       RETURN           
  1232. C                      
  1233.    60 N = LPT(6) - LPT(1)                 
  1234.       DO 61 I = 1, N   
  1235.          J = L+I-1     
  1236.          K = LIN(J)    
  1237.          BUF(I) = ALFA(K+1)               
  1238.          IF (CASE.EQ.1 .AND. K.LT.36) BUF(I) = ALFB(K+1)     
  1239.    61 CONTINUE         
  1240.       CALL EDIT(BUF,N)                    
  1241.       N = N + 1        
  1242.       GO TO 15         
  1243.       END
  1244.               
  1245.       SUBROUTINE GETSYM                   
  1246. C     GET A SYMBOL     
  1247.       DOUBLE PRECISION STKR(5005),STKI(5005)                 
  1248.       INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP        
  1249.       INTEGER ALFA(52),ALFB(52),ALFL,CASE                    
  1250.       INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE           
  1251.       INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)            
  1252.       COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP          
  1253.       COMMON /ALFS/ ALFA,ALFB,ALFL,CASE   
  1254.       COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE                  
  1255.       COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN  
  1256. SHAR_EOF
  1257. #    End of shell archive
  1258. exit 0
  1259. -- 
  1260. Bob Page, U of Lowell CS Dept.  page@swan.ulowell.edu  ulowell!page
  1261. Have five nice days.
  1262.